home *** CD-ROM | disk | FTP | other *** search
/ The Original Shareware 1.1 / The Original Shareware (WeMake CDs)(Volume 1.1)(CDs, Inc)(1993).iso / 38 / sgn_bans.zip / EDITFONT.PAS < prev    next >
Pascal/Delphi Source File  |  1985-12-04  |  14KB  |  487 lines
  1. { EditFont.Pas, the font editor for SignSmif.Pas }
  2.  
  3. { Start Global declarations }
  4.  
  5. Const
  6.   xtik = 16 ;
  7.   ytik = 6 ;
  8.   M : array[0..7] of byte = ($80,$40,$20,$10,$08,$04,$02,$01) ;
  9.   WM : array[0..15] of integer =
  10.            ($8000,$4000,$2000,$1000,$0800,$0400,$0200,$0100,
  11.             $0080,$0040,$0020,$0010,$0008,$0004,$0002,$0001) ;
  12. type
  13.   Font1 = array[0..255,0..7] of byte ;
  14.   Font2 = array[0..255,0..13] of byte ;
  15.   Font3 = array[0..255,0..13] of integer ;
  16.   Font4 = array[0..255,0..27] of integer ;
  17.  
  18. Var
  19.   hsize, vsize, hsp1, vsp1, nhor, nvert : integer ;
  20.   LastRow, LastCol : integer ;
  21.   TLX, TLY, BRX, BRY : integer ; { top left x, etc. }
  22.   ch, tch : char ;
  23.   bitmap : array[0..27,0..15] of byte ;
  24.   CharMap1 : Font1 ;
  25.   CharMap2 : Font2 ;
  26.   CharMap3 : Font3 ;
  27.   CharMap4 : Font4 ;
  28.   FontFile1 : file of Font1 ;
  29.   FontFile2 : file of Font2 ;
  30.   FontFile3 : file of Font3 ;
  31.   FontFile4 : file of Font4 ;
  32.   FontName : string[30] ;
  33.   FontNumber : integer ;
  34.   asc : byte ;
  35.   FuncKey : boolean ;
  36.  
  37. {ZZZ$I Hex.Pas }
  38.  
  39. Procedure LoadBitMap(a : char ) ;
  40.  
  41. Var j, k : integer ;
  42.  
  43. begin
  44.   for j := 0 to LastRow do
  45.   begin
  46.     for k := 0 to LastCol do
  47.     begin
  48.       case FontNumber of
  49.         1 : begin
  50.               if ( ( Charmap1[ord(a),j] and M[k] ) <> 0 )
  51.               then BitMap[j,k] := 1 else BitMap[j,k] := 0 ;
  52.         end ; { 1 }
  53.         2 : begin
  54.               if ( ( Charmap2[ord(a),j] and M[k] ) <> 0 )
  55.               then BitMap[j,k] := 1 else BitMap[j,k] := 0 ;
  56.         end ; { 2 }
  57.         3 : begin
  58.               if ( ( Charmap3[ord(a),j] and WM[k] ) <> 0 )
  59.               then BitMap[j,k] := 1 else BitMap[j,k] := 0 ;
  60.         end ; { 3 }
  61.         4 : begin
  62.               if ( ( Charmap4[ord(a),j] and WM[k] ) <> 0 )
  63.               then BitMap[j,k] := 1 else BitMap[j,k] := 0 ;
  64.         end ; { 4 }
  65.       end ; { case }
  66.     end ; { k }
  67. {    writeln ; }
  68.   end ; { j }
  69. end ;
  70.  
  71. Procedure UnLoadBitMap(a : char ) ;
  72.  
  73. Var
  74.   j, k : integer ;
  75.   bi : integer ;
  76.   bb : byte ;
  77.  
  78. begin
  79.   for j := 0 to LastRow do
  80.   begin
  81.     case FontNumber of
  82.       1 : begin
  83.             bb := 0 ;
  84.             for k := 0 to LastCol do
  85.               if BitMap[j,k] <> 0 then bb := ( bb or M[k] ) ;
  86.             CharMap1[ord(a),j] := bb ;
  87.           end ; { 1 }
  88.       2 : begin
  89.             bb := 0 ;
  90.             for k := 0 to LastCol do
  91.               if BitMap[j,k] <> 0 then bb := ( bb or M[k] ) ;
  92.             CharMap2[ord(a),j] := bb ;
  93.           end ; { 2 }
  94.       3 : begin
  95.             bi := 0 ;
  96.             for k := 0 to LastCol do
  97.               if BitMap[j,k] <> 0 then bi := ( bi or WM[k] ) ;
  98.             CharMap3[ord(a),j] := bi ;
  99.           end ; { 3 }
  100.       4 : begin
  101.             bi := 0 ;
  102.             for k := 0 to LastCol do
  103.               if BitMap[j,k] <> 0 then bi := ( bi or WM[k] ) ;
  104.             CharMap4[ord(a),j] := bi ;
  105.           end ; { 4 }
  106.       end ; { case }
  107.   end ; { j }
  108. end ; { unload }
  109.  
  110. Procedure DrawTicks(x,y,shade : integer) ;
  111.  
  112. Var
  113.   txb,lyb : integer ;
  114.  
  115. begin
  116.   txb := tlx + x*hsp1 + hsize div 2 ;
  117.   lyb := tly + y*vsp1 + vsize div 2 ;
  118.   draw(tlx-xtik,lyb,tlx-1,lyb,shade) ; { left   tick }
  119.   draw(brx+1,lyb,brx+xtik,lyb,shade) ; { right  tick }
  120.   draw(txb,tly-ytik,txb,tly-1,shade) ; { top    tick }
  121.   draw(txb,bry+1,txb,bry+ytik,shade) ; { bottom tick }
  122.   draw(txb+1,tly-ytik,txb+1,tly-1,shade) ; { extra top tick }
  123.   draw(txb+1,bry+1,txb+1,bry+ytik,shade) ; { & bottom tick }
  124. end ;
  125.  
  126. Procedure MoveTicks(xold,yold,xnew,ynew : integer) ;
  127.  
  128. begin
  129.   DrawTicks(xold,yold,0) ;
  130.   DrawTicks(xnew,ynew,1) ;
  131. end ;
  132.  
  133. Procedure FillBlock(xloc,yloc,shade : integer) ;
  134.  
  135. Var
  136.   j, k : integer ;
  137.   tlxb,tlyb,brxb,bryb,tlybj : integer ;
  138.  
  139. begin
  140.   tlxb := tlx + xloc*hsp1 + 1 ;
  141.   tlyb := tly + yloc*vsp1 + 1 ;
  142.   brxb := tlxb + hsize - 1 ;
  143.   bryb := tlyb + vsize - 1 ;
  144.   for j := tlyb to bryb do draw(tlxb,j,brxb,j,shade) ;
  145. end ;
  146.  
  147.  
  148. Procedure DrawGrid ;
  149.  
  150. Var
  151.   j, k : integer ;
  152.  
  153. begin
  154.   for j := 0 to nvert do
  155.   begin
  156.     k := tly + j*vsp1 ;
  157.     draw(tlx,k,brx,k,1) ;
  158.   end ;
  159.   for j := 0 to nhor do
  160.   begin
  161.     k := tlx + j*hsp1 ;
  162.     draw(k,tly,k,bry,1) ;
  163.   end ;
  164. end ;
  165.  
  166. Procedure FillInTheGrid ;
  167.  
  168. Var j, k : integer ;
  169.  
  170. begin
  171.   for j := 0 to LastRow do
  172.     for k := 0 to LastCol do
  173.         FillBlock(k,j,BitMap[j,k]) ;
  174. end ;
  175.  
  176. Procedure MakeNewCharacter ;
  177.  
  178. begin
  179.   Hires ;
  180.   HiresColor(7) ;
  181.   DrawGrid ;
  182.   FillInTheGrid ;
  183.   gotoxy(1,23) ;
  184.   Writeln('Use keypad arrow keys, Ins, Del') ;
  185.   gotoxy(1,25) ;
  186.   write('F1 for new character, F10 to exit') ;
  187.   gotoxy(54,18) ;
  188.   write('F2 = Import character') ;
  189.   gotoxy(54,19) ;
  190.   write('CAUTION - see manual') ;
  191.   gotoxy(54,21) ;
  192.   write('Flips, F3=Left-Rt, F4=Up-Dn') ;
  193.   gotoxy(54,23) ;
  194.   write('Move Entire Character') ;
  195.   gotoxy(55,24) ;
  196.   write('    (Slowly !)') ;
  197.   gotoxy(55,25) ;
  198.   write('F5=',#24,' F6=',#25,' F7=',#27,' F8=',#26) ;
  199. end ;
  200.  
  201. { **** ------------------------------------------------------------ }
  202.  
  203. Var
  204.   j, k, row, col, trow, tcol, newrow, newcol : integer ;
  205.   keychar : char ;
  206.   spotx, spoty, spot : integer ;
  207.   tbyte : byte ;
  208.  
  209. begin
  210.   repeat
  211.     ClrScr ;
  212.     write('What type of font do you want to edit, 1 to 4  ?   ') ;
  213.     readln(FontNumber) ;
  214.   until FontNumber in [1..4] ;
  215.  
  216.   tlx   := 200 ; tly   := 30 ;
  217.   case FontNumber of
  218.     1 : begin
  219.           hsize := 12   ; vsize := 8  ;
  220.           nHor  := 8    ; nVert := 8 ;
  221.         end ; { 1 }
  222.     2 : begin
  223.           hsize := 10   ; vsize := 4  ;
  224.           nHor  := 8    ; nVert := 14 ;
  225.         end ; { 2 }
  226.     3 : begin
  227.           hsize := 8   ; vsize := 6  ;
  228.           nHor  := 16   ; nVert := 14 ;
  229.         end ; { 3 }
  230.     4 : begin
  231.           hsize := 8   ; vsize := 4  ;
  232.           nHor  := 16   ; nVert := 28 ;
  233.         end ; { 4 }
  234.     end ; { case }
  235.  
  236.   LastCol := nHor - 1 ;
  237.   LastRow := nVert - 1 ;
  238.  
  239.   hsp1  := hsize + 1 ;
  240.   vsp1  := vsize + 1 ;
  241.  
  242.   brx := tlx + nhor  * hsp1 ;
  243.   bry := tly + nvert * vsp1 ;
  244.  
  245.   clrscr ;  gotoxy(1,1) ;
  246.   repeat
  247.     writeln('Enter full name of font file, including') ;
  248.     write('drive and directory if needed   ') ;
  249.     readln(FontName) ;
  250.     case FontNumber of
  251.       1 : begin
  252.             assign(FontFile1,FontName) ;
  253.             {$I-}
  254.             reset(FontFile1) ;
  255.             {$I+}
  256.           end ; { 1 }
  257.       2 : begin
  258.             assign(FontFile2,FontName) ;
  259.             {$I-}
  260.             reset(FontFile2) ;
  261.             {$I+}
  262.           end ; { 2 }
  263.       3 : begin
  264.             assign(FontFile3,FontName) ;
  265.             {$I-}
  266.             reset(FontFile3) ;
  267.             {$I+}
  268.           end ; { 3 }
  269.       4 : begin
  270.             assign(FontFile4,FontName) ;
  271.             {$I-}
  272.             reset(FontFile4) ;
  273.             {$I+}
  274.           end ; { 4 }
  275.     end ; { case }
  276.     j := IOresult ;
  277.     if j <> 0 then writeln('File not found.  Try again.') ;
  278.   until j = 0 ;
  279.  
  280.   case FontNumber of
  281.     1 :  read(FontFile1,CharMap1) ;
  282.     2 :  read(FontFile2,CharMap2) ;
  283.     3 :  read(FontFile3,CharMap3) ;
  284.     4 :  read(FontFile4,CharMap4) ;
  285.   end ; { case }
  286.   repeat
  287.     textmode(bw80) ;
  288.     clrscr ;
  289.     gotoxy(1,1) ;
  290.     write('':75) ;
  291.     gotoxy(1,2) ;
  292.     write('':75) ;
  293.     gotoxy(1,1) ;
  294.     write('Enter character to be edited          ') ;
  295.     readln(ch) ;
  296.     LoadBitMap(ch) ;
  297.  
  298.     MakeNewCharacter ;
  299.     col := LastCol div 2 + 1 ; row := LastRow div 2 + 1 ;
  300.     MoveTicks(0,0,col,row) ;
  301.  
  302.     repeat
  303.       funckey := false ;
  304.       { blinking spot cursor stuff }
  305.       spotx := tlx + col*hsp1 + hsize div 2 ;
  306.       spoty := tly + row*vsp1 + vsize div 2 ;
  307.       spot := 1 - BitMap[row,col] ; { contrasting colour }
  308.       plot(spotx  ,spoty  ,spot) ;  { make spot on cell }
  309.       plot(spotx+1,spoty  ,spot) ;
  310.       plot(spotx+1,spoty+1,spot) ;
  311.       plot(spotx  ,spoty+1,spot) ;
  312.       repeat until keypressed ;
  313.  
  314.       spot := 1 - spot ;            { remove the cursor spot }
  315.       plot(spotx  ,spoty  ,spot) ;
  316.       plot(spotx+1,spoty  ,spot) ;
  317.       plot(spotx+1,spoty+1,spot) ;
  318.       plot(spotx  ,spoty+1,spot) ;
  319.  
  320.       read(KBD,keychar) ;
  321.       if (keychar = #27) and keypressed then
  322.       begin
  323.         read(KBD,keychar) ;
  324.         funckey := true ;
  325.       end ;
  326.  
  327.       if funckey then
  328.       begin
  329.         newcol := col ;
  330.         newrow := row ;
  331.  
  332.         if keychar in [#75,#77,#72,#80] then
  333.         begin
  334.           case(keychar) of
  335.             #75 : newcol := col - 1 ; { left }
  336.             #77 : newcol := col + 1 ; { right }
  337.             #72 : newrow := row - 1 ; { up }
  338.             #80 : newrow := row + 1 ; { down }
  339.           end ; { case }
  340.           if (newcol in [0..LastCol]) and (newrow in [0..LastRow]) then
  341.           begin
  342.             MoveTicks(col,row,newcol,newrow) ;
  343.             col := newcol ;
  344.             row := newrow ;
  345.           end
  346.           else
  347.           begin
  348.             sound(5000) ;
  349.             delay(100) ;
  350.             nosound ;
  351.           end ;
  352.         end ; { in [#75 etc }
  353.  
  354.         case(keychar) of
  355.           #82 : begin { insert }
  356.                   BitMap[row,col] := 1 ;
  357.                   FillBlock(col,row,1) ;
  358.                 end ;
  359.           #83 : begin { delete }
  360.                   BitMap[row,col] := 0 ;
  361.                   FillBlock(col,row,0) ;
  362.                 end ;
  363.           #59,#68 : begin { F1 or F10 }
  364.                       UnLoadBitMap(ch) ;
  365.                     end ;
  366.         end ; { case }
  367.  
  368.         if keychar in [#60..#66] then
  369.         begin
  370.           case keychar of
  371.             #60 : begin          { F2, import character }
  372.               textmode(bw80) ;
  373.               clrscr ;
  374.               gotoxy(1,1) ;
  375.               write('Enter character to import in place of ',ch) ;
  376.               gotoxy(1,2) ;
  377.               write('(use period as a signal to quit).    ') ;
  378.               readln(tch) ;
  379.               gotoxy(1,1) ;
  380.               write('                                                    ') ;
  381.               gotoxy(1,2) ;
  382.               write('                                            ') ;
  383.               if tch <> '.' then LoadBitMap(tch) ;
  384.               MakeNewCharacter ;
  385.               MoveTicks(0,0,col,row) ;
  386.             end ; { #60 }
  387.             #61 : begin          { F3, flip left-right }
  388.               for trow := 0 to LastRow do
  389.               begin
  390.                 for tcol := 0 to (LastCol div 2) do
  391.                 begin
  392.                   tbyte := BitMap[trow,tcol] ;
  393.                   BitMap[trow,tcol] := BitMap[trow,LastCol-tcol] ;
  394.                   BitMap[trow,LastCol-tcol] := tbyte ;
  395.                 end ; { tcol }
  396.               end ; { trow }
  397.             end ; { #61 }
  398.             #62 : begin          { F4, top-bot }
  399.               for tcol := 0 to LastCol do
  400.               begin
  401.                 for trow := 0 to (Lastrow div 2) do
  402.                 begin
  403.                   tbyte := BitMap[trow,tcol] ;
  404.                   BitMap[trow,tcol] := BitMap[LastRow-trow,tcol] ;
  405.                   BitMap[LastRow-trow,tcol] := tbyte ;
  406.                 end ; { trow }
  407.               end ; { tcol }
  408.             end ; { #62 }
  409.             #63 : begin          { F5, move up }
  410.               for trow := 1 to LastRow do
  411.               begin
  412.                 for tcol := 0 to LastCol do
  413.                   BitMap[trow-1,tcol] := BitMap[trow,tcol] ;
  414.               end ; { trow }
  415.               for tcol := 0 to LastCol do
  416.                 BitMap[LastRow,tcol] := 0 ;
  417.             end ; { #63 }
  418.             #64 : begin          { F6, move down }
  419.               for trow := LastRow downto 1 do
  420.               begin
  421.                 for tcol := 0 to LastCol do
  422.                   BitMap[trow,tcol] := BitMap[trow-1,tcol] ;
  423.               end ; { trow }
  424.               for tcol := 0 to LastCol do
  425.                 BitMap[0,tcol] := 0 ;
  426.             end ; { #64 }
  427.             #65 : begin          { F7, move left }
  428.                     for trow := 0 to LastRow do
  429.                     begin
  430.                       for tcol := 1 to LastCol do
  431.                               BitMap[trow,tcol-1] := BitMap[trow,tcol] ;
  432.                       BitMap[trow,LastCol] := 0 ;
  433.                     end ; { trow }
  434.             end ; { #65 }
  435.             #66 : begin          { F8, move right }
  436.                     for trow := 0 to LastRow do
  437.                     begin
  438.                       for tcol := LastCol downto 1 do
  439.                                 BitMap[trow,tcol] := BitMap[trow,tcol-1] ;
  440.                       BitMap[trow,0] := 0 ;
  441.                     end ; { trow }
  442.             end ; { #66 }
  443.           end ; { case }
  444.           FillInTheGrid ;
  445.         end ; { if keychar in [#63.. }
  446.       end ; { funckey }
  447.     until keychar in [#59,#68] ; { F1 or F10 }
  448.  
  449.   until keychar = #68 ; { F10 }
  450.  
  451.   repeat
  452.     gotoxy(1,1) ;
  453.     write('Update file ',FontName,'  ? (y/n)  ') ;
  454.     readln(ch) ;
  455.     ch := UpCase(ch) ;
  456.   until ch in ['Y','N'] ;
  457.  
  458.   if ch = 'Y' then
  459.   begin
  460.     case FontNumber of
  461.       1 : begin ;
  462.             rewrite(FontFile1) ;
  463.             Write(FontFile1,CharMap1) ;
  464.             Close(FontFile1) ;
  465.           end ; { 1 }
  466.       2 : begin ;
  467.             rewrite(FontFile2) ;
  468.             Write(FontFile2,CharMap2) ;
  469.             Close(FontFile2) ;
  470.           end ; { 2 }
  471.       3 : begin ;
  472.             rewrite(FontFile3) ;
  473.             Write(FontFile3,CharMap3) ;
  474.             Close(FontFile3) ;
  475.           end ; { 3 }
  476.       4 : begin ;
  477.             rewrite(FontFile4) ;
  478.             Write(FontFile4,CharMap4) ;
  479.             Close(FontFile4) ;
  480.           end ; { 4 }
  481.       end ; { case }
  482.   end ;
  483.  
  484.   textmode(bw80) ;
  485.   clrscr ;
  486. end .
  487.